;;; =========================================================
;;;                         SCANNER
;;; =========================================================
(define file->list
  (lambda (filename)
    (let ((port (open-input-file filename)))
      (letrec ((loop
		(lambda ()
		  (let ((ch (read-char port)))
		    (if (eof-object? ch) '()
			(cons ch (loop)))))))
	(let ((s (loop)))
	  (close-input-port port)
	  s)))))

(define list->tokens
  (letrec ((st-init
	    (lambda (s)
	      (cond ((null? s) '())

                    ((char=? (car s) #\`)                       ; |Quasi-quote|
		     `((quasiquote) ,@(st-init (cdr s))))
         
                    ((char=? (car s) #\')                       ; |Single-quote|
		     `((single-quote) ,@(st-init (cdr s))))

                    ((char=? (car s) #\()                       ; |lparen|
		     `((lparen) ,@(st-init (cdr s))))

   		    ((char=? (car s) #\))                       ; |rparen|
		     `((rparen) ,@(st-init (cdr s))))

                    ((char=? (car s) #\;)                       ; GOTO: st-comment
		     (st-comment s))
         
   		    ((char=? (car s) #\,)                       ; GOTO: st-unquote
   		     (st-unquote (cdr s)))

                    ((char-sign? (car s))                       ; GOTO: st-sign
                     (st-sign (cdr s) `(,(car s))))

   		    ((char=? (car s) #\.)                       ; GOTO: st-dot-or-sym
		     (st-dot-or-sym (cdr s) `(,(car s))))
        
                    ((char-numeric? (car s))                    ; GOTO: st-num-or-sym
                     (st-num-or-sym (cdr s) `(,(car s))))
         
                    ((or (char-special? (car s))                ; GOTO: st-sym
                         (char-alphabetic? (car s)))
                     (st-sym (cdr s) `(,(car s))))
         
                    ((char=? (car s) #\")                       ; GOTO: st-string
                     (st-string (cdr s) `()))
         
                    ((char=? (car s) #\#)                       ; GOTO: st-hash
                     (st-hash (cdr s)))
         
                    ((char-whitespace? (car s))
		     (st-init (cdr s)))
		    (else (scanner-error "st-init: unrecognized " s)))))

       	   (st-comment
	    (lambda (s)
	      (cond ((null? s) (st-init '())) ; only terminate in one place!
		    ((char=? (car s) #\newline) (st-init (cdr s)))
		    (else (st-comment (cdr s))))))

           (st-unquote
	    (lambda (s)
	      (cond ((null? s)
                     `(,'(unquote) ,@(st-init '())))
                    ((char=? (car s) #\@)
                     `(,'(unquote-splicing) ,@(st-init (cdr s))))
                    (else
                     `(,'(unquote) ,@(st-init s))))))
           
           (st-sign
             (lambda (s lexeme)
               (cond ((char-numeric? (car s))
                      (st-num-or-sym s lexeme))
                     (else 
                      (st-sym s lexeme)))))
           
           (st-dot-or-sym
             (lambda (s lexeme)
               (cond ((null? s)
                      `((dot) ,@(st-init '())))
                     ((char-whitespace? (car s))
                      `((dot) ,@(st-init (cdr s))))
                     ((or (char-special? (car s))
                          (char-numeric? (car s))
                          (char-alphabetic? (car s)))
                      (st-sym s lexeme))
                     (else
                      `((dot) ,@(st-init s))))))

           (st-num-or-sym
             (lambda (s lexeme)
               (cond ((null? s)
                     `((number ,(lexeme->number lexeme)) ,@(st-init '())))
                     ((char-whitespace? (car s))
                      `((number ,(lexeme->number lexeme)) ,@(st-init (cdr s))))
                     ((char-numeric? (car s))
                      (st-num-or-sym (cdr s) (cons (car s) lexeme)))
                     ((or (char-special? (car s))
                          (char-alphabetic? (car s)))
                      (st-sym s lexeme))
                     (else
                      `((number ,(lexeme->number lexeme)) ,@(st-init s))))))
           
           (st-sym
	    (lambda (s lexeme)
	      (cond ((null? s)
                     `((symbol ,(lexeme->symbol lexeme)) ,@(st-init '())))
                    ((char-whitespace? (car s))
                     `((symbol ,(lexeme->symbol lexeme)) ,@(st-init (cdr s))))
                    ((or (char-special? (car s))
                         (char-numeric? (car s))
                         (char-alphabetic? (car s)))
                     (st-sym (cdr s) (cons (car s) lexeme)))
                    (else 
                     `((symbol ,(lexeme->symbol lexeme)) ,@(st-init s))))))
           
           (st-string
             (lambda (s lexeme)
               (cond ((null? s)
                      (scanner-error "st-string: Err " s))
                     ((char=? (car s) #\\)
                      (st-string-mc (cdr s) lexeme))
                     ((char=? (car s) #\")
                      `((string ,(list->string (reverse lexeme))) ,@(st-init (cdr s))))
                     (else 
                       (st-string (cdr s) (cons (car s) lexeme))))))
           
           (st-string-mc
             (lambda (s lexeme)
               (cond ((null? s)
                      (st-string s lexeme))
                     ((char=? (car s) #\\)
                      (st-string (cdr s) (cons #\\ lexeme)))
                     ((char=? (car s) #\")
                      (st-string (cdr s) (cons #\" lexeme)))
                     ((char=? (car s) #\n)
                      (st-string (cdr s) (cons #\newline lexeme)))
                     ((char=? (car s) #\t)
                      (st-string (cdr s) (cons #\tab lexeme)))
                     (else 
                       (st-string (cdr s) (cons #\ lexeme))))))        
           
           (st-hash
             (lambda (s)
               (cond ((null? s)
                      (scanner-error "st-hash: unrecognized " s))
                     
                     ((char-ci=? (car s) #\t)                   ; |boolean #t|
                      `((boolean #t) ,@(st-init (cdr s))))
                     
                     ((char-ci=? (car s) #\f)                   ; |boolean #f|
                      `((boolean #f) ,@(st-init (cdr s))))
                     
                     ((char=? (car s) #\()
                      `((vector) ,@(st-init (cdr s))))
                     
                     ((char=? (car s) #\\)
                      (st-char (cdr s)))
                     
                     (else (scanner-error "st-hash: unrecognized " s)))))
           
           (st-char
             (lambda (s)
               (cond ((null? s)
                      (scanner-error "st-char: unrecognized " s))

                     ((char-octal? (car s))
                      (st-char-octOrRegular (cdr s) `(,(car s))))
                     
                     ((is-prefix (string->list "newline") s)
                      `((char #\newline) ,@(st-init (n-cdr s 7))))
                     
                     ((is-prefix (string->list "space") s)
                      `((char #\space) ,@(st-init (n-cdr s 5))))
                     
                     ((is-prefix (string->list "tab") s)
                      `((char #\tab) ,@(st-init (n-cdr s 3))))
                     
                     (else (st-charRegular (cdr s) (car s))))))

           
           (st-char-octOrRegular ; Called with oct='(?) where ? is in [0-7]
             (lambda (s oct)
               (cond ((eq? (length oct) 3) ; contains 3 octal digit chars
                      `((char ,(oct-list->char oct)) ,@(st-init s)))
                     ((null? s)
                      (st-charRegular s oct))
                     ((char-octal? (car s))
                      (st-char-octOrRegular (cdr s) (cons (car s) oct)))
                     (else 
                       (st-charRegular s oct)))))
           
           (st-charRegular
             (lambda (s lexeme)
               (if (char? lexeme)                               ; If lexeme is a character, 
                   `((char ,lexeme) ,@(st-init s))              ; this state was called by
                                                                ; st-char.
                   (let* ((lexRev (reverse lexeme))             ; Else, it was called by
                          (rest   (append (cdr lexRev) s)))     ; st-char-octOrRegular.
                     `((char ,(car lexRev)) ,@(st-init s)))))))
    (lambda (s)
      (st-init s))))

(define char-whitespace?
  (lambda (char)
    (char<=? char #\space)))

(define char-special?
  (lambda (char)
    (ormap (lambda (c) (char=? char c))
      '(#\- #\_ #\! #\@ #\$ #\% #\^ #\& #\* #\+ #\= #\: #\< #\> #\? #\. #\~ #\/))))

(define char-sign?
  (lambda (char)
    (or (char=? char #\-)
        (char=? char #\+))))

(define char-octal?
   (lambda (char)
     (and (char>=? char #\0)
          (char<=? char #\7))))
 
(define lexeme->number
  (lambda (lexeme)
    (string->number (list->string (reverse lexeme)))))

(define lexeme->symbol
  (lambda (lexeme)
    (let ((lower-lexeme (map char-downcase lexeme)))
      (let ((rev-lexeme (reverse lower-lexeme)))
        (string->symbol (list->string rev-lexeme))))))

(define oct-list->char
  (lambda (lexeme)
    (letrec ((oct->dec (lambda (oct i res)
                         (if (eq? oct 0)
                             res
                             (let ((lsb (remainder oct 10)))
                               (oct->dec (/ (- oct lsb) 10)
                                         (+ i 1)
                                         (+ res (* lsb (expt 8 i))))))))
             (oct (string->number (list->string (reverse lexeme)))))
      (integer->char (oct->dec oct 0 0)))))

(define is-prefix
  (lambda (s1 s2)
    (cond ((null? s1) #t)
          ((null? s2) #f)
          ((> (length s1) (length s2)) #f)
          ((eq? (car s1) (car s2)) (is-prefix (cdr s1) (cdr s2)))
          (else #f))))

;pre-conditions: (not (null? s))
(define n-cdr
  (lambda (s n)
    (if (eq? n 0)
        s
        (n-cdr (cdr s) (- n 1)))))

(define scanner-error
  (lambda (message s)
    (if (null? s)
	(error 'list-tokens message)
	(error 'list-tokens
	       (format "~a: [~s]~a"
		       message
		       (car s)
		       (list->string (cdr s)))))))

(define file->tokens
  (lambda (filename)
    (list->tokens
     (file->list filename))))

;;; =========================================================
;;;                          READER
;;; =========================================================
;;; A top-down parser for a subset of the grammar of sexprs.
;;; Sexpr -> Boolean | Char | Number | String | Symbol | List 
;;;          | ImproperList | Vector | Quoted | QuasiQuoted 
;;;          | Unquoted | UnquoteAndSpliced
(define tokens->sexprs
  (lambda (tokens)
    (get-sexprs tokens                                          
     (lambda (s tokens)                                                        ; -+
       (if (null? tokens)                                                      ;  |
	   s                                                                   ;  |==> Cont to get sexprs
	   (error 'tokens->sexpr                                               ;  |
		  "Error: read ~s with remaining tokens ~s"                    ;  |
		   s tokens))))))                                              ; -+

(define get-sexpr
  (lambda (tokens ret-sexpr+tokens ret-none)
    (cond (
           (or (null? tokens)                                                  ; If either the list of remaining tokens is empty
               (ormap (lambda (delim-token) (eq? (caar tokens) delim-token))   ; or the first token in the list is (dot) or (rparen),
                      '(dot rparen)))                                          ; apply the fail continuation to the result (an sexpr
	   (ret-none))                                                         ; an must not begin with dot or right parenthesis.
          
          ;;; Supports the following derivation rules:
          ;;; Boolean -> (boolean #f) | (boolean #t)
          ;;; Char    -> (char ch)
          ;;; Number  -> (number num)
          ;;; String  -> (string str)
          ;;; Symbol  -> (symbol sym)
	  ((ormap (lambda (simple-token) (eq? (caar tokens) simple-token))
                  '(boolean char number string symbol))
	   (ret-sexpr+tokens (cadar tokens) (cdr tokens)))

          ;;; Supports the following derivation rules:
          ;;; List -> (rparen) SexprList (lparen)
          ;;; SexprList -> Sexpr SexprList | epsilon
          ;;; ImproperList -> (lparen) Sexpr SeprList (dot) (rparen)
          ((eq? (caar tokens) 'lparen)
           (get-sexprs (cdr tokens)
                       (lambda (sexprs tokens)
                         (cond ((null? tokens)
                               (reader-error "Expecting rparen"))
                               ((eq? (caar tokens) 'rparen)
                                (ret-sexpr+tokens sexprs (cdr tokens)))
                               ((eq? (caar tokens) 'dot)
                                (get-sexpr (cdr tokens)
                                           (lambda (sexpr tokens)
                                             (cond ((null? tokens)
                                                    (reader-error "Expecting rparen"))
                                                   ((eq? (caar tokens) 'rparen)
                                                    (improper-append$ sexprs
                                                                      sexpr
                                                                      (lambda (res)
                                                                        (ret-sexpr+tokens res (cdr tokens)))))
                                                   (else (reader-error "Expecting rparen"))))
                                           (lambda () (reader-error "Expecting sexpr"))))
                                (else (reader-error "Expecting rparen"))))))
          
          ;;; Supports the following derivation rules:
          ;;; Vector -> (vector) SexprList (rparen)
          ((eq? (caar tokens) 'vector)
           (get-sexprs (cdr tokens)
                       (lambda (sexprs tokens)
                         (cond ((null? tokens) 
                                (reader-error "Expecting rparen"))
                               ((eq? (caar tokens) 'rparen)
                                (ret-sexpr+tokens (list->vector sexprs) (cdr tokens)))
                               (else (reader-error "Expecting rparen"))))))
          
          ;;; Supports the following derivation rules:
          ;;; Quoted -> (single-quote) Sexpr
	  ((eq? (caar tokens) 'single-quote)
	   (get-sexpr (cdr tokens)
            (lambda (sexpr tokens) (ret-sexpr+tokens `',sexpr tokens))
	    (lambda () (reader-error "Expecting an sexpr" tokens))))

          ;;; Supports the following derivation rules:
          ;;; QuasiQuoted -> (quasiquote) Sexpr
          ((eq? (caar tokens) 'quasiquote)
           (get-sexpr (cdr tokens)
                      (lambda (sexpr tokens) (ret-sexpr+tokens (list `quasiquote sexpr) tokens)) ;Succ
                      (lambda () (reader-error "Expecting an sexpr" tokens))))   ;Fail

          ;;; Supports the following derivation rules:
          ;;; Quoted -> (single-quote) Sexpr
          ((eq? (caar tokens) 'unquote-splicing)
           (get-sexpr (cdr tokens)
                      (lambda (sexpr tokens) (ret-sexpr+tokens (list `unquote-splicing sexpr) tokens)) ; Succ
                      (lambda () (reader-error "Expecting an sexpr" tokens))))    ; Fail

          ;;; Supports the following derivation rules:
          ;;; Quoted -> (single-quote) Sexpr
          ((eq? (caar tokens) 'unquote)
           (get-sexpr (cdr tokens)
                      (lambda (sexpr tokens) (ret-sexpr+tokens (list `unquote sexpr) tokens)) ; Succ
                      (lambda () (reader-error "Expecting an sexpr" tokens))))    ; Fail
          
	  (else (reader-error "What's this" tokens)))))
  
(define get-sexprs
  (lambda (tokens ret-sexprs+tokens)
    (get-sexpr tokens
     (lambda (sexpr tokens)
       (get-sexprs tokens
	(lambda (sexprs tokens)
	  (ret-sexprs+tokens (cons sexpr sexprs) tokens))))
     (lambda ()
       (ret-sexprs+tokens '() tokens)))))

(define reader-error
  (lambda (message . s)
    (if (null? s)
	(error 'reader message)
	(error 'reader
	       (format "~a: [~s] ~s" message (car s) (cdr s))))))

(define improper-append$
  (lambda (li x cont)
    (cond ((null? li) (cont "Err creating improper list"))
          ((null? (cdr li)) (cont (cons (car li) x)))
          (else (improper-append$ (cdr li) x (lambda (res)
                                               (cont (cons (car li) res))))))))

;;; =========================================================
;;;                        TAG PARSER
;;; =========================================================
;;; A hand-coded tag-parser for Scheme. The function parse 
;;; takes an sexpr as an argument, and returns a parsed sexpr.
(define parse
  (lambda (e)
    (cond 

      ;;; CONSTANTS
      ;;; ---------
      ;;; Booleans, Characters, Numbers, Strings, vectors and void
      ((and (not (pair? e)) (const? e)) `(const ,e))
      
      ;;; VARIABLES
      ;;; ---------
      ((and (not (pair? e)) (not (const? e)) (not (reserved? e)))
       `(var ,e))
      
      ;;; QUOTED EXPRESSIONS
      ;;; ------------------
      ((and (pair? e) (eq? (car e) 'quote) (pair? (cdr e)) (null? (cddr e)))
       `(const ,(cadr e)))
      
      ;;; QUASIQUOTED EXPRESSIONS
      ;;; -----------------------
      ((and (pair? e) (eq? (car e) 'quasiquote) (pair? (cdr e)) (null? (cddr e)))
       (parse (qq-expand (cadr e))))
      
      ;;; CONDITIONALS
      ;;; ------------
      ((and (pair? e) (eq? (car e) 'if) (pair? (cdr e)) (pair? (cddr e)))
       (cond ((null? (cdddr e))
              (parse (if-2-expand e)))
             ((and (pair? (cdddr e))
                   (null? (cddddr e))) 
              `(if-3 ,@(map parse (cdr e))))
             (else (error "not-an-if-exp"))))
     
      ;;; LAMBDA FORMS
      ;;; ------------
      ((and (pair? e) (eq? (car e) 'lambda) (pair? (cdr e))     ;;; A pair of 'lambda' and another pair
            (not (improper? (cddr e))) (not (null? (cddr e))))  ;;; of which cdr represents a 'body'
                                                                ;;; including at least one expression.
       (let* ((vars (cadr e))
              (exps (split-define (cddr e)))
              (def-block (car exps))
              (body-rest (cdr exps))
              (improper (improper? vars)))
         (if (null? def-block)
             (cond 
               ((not improper)                                      ;;; (lambda (V1 ... Vn) E1 ... En)
                (if (set? vars)                                     ;;; verify variable list is a set
                    `(lambda-simple ,vars ,(seq (map parse body-rest)))
                    (error "invalid parameter list in" e)))
               ((not (null? (car improper)))                        ;;; (lambda (v1 ... vn . v-rest) e1 ... em)
                (if (set? (cons (cadr improper) (car improper)))    ;;; verify variable list is a set
                    `(lambda-opt ,(car improper) 
                                 ,(cadr improper) ,(seq (map parse body-rest)))
                    (error "invalid parameter list in" e)))  
               (else                                                ;;; (lambda args e1 ... em) where args is a variable
                `(lambda-variadic ,vars ,(seq (map parse body-rest)))))
             (parse `(lambda ,vars 
                       (letrec 
                           ,(map (lambda (def) 
                                   (if (pair? (cadr def))
                                       (cdr (mit-expand def))
                                       (cdr def)))
                                 def-block)
                         ,@body-rest))))))
      
      ;;; SET! EXPRESSIONS
      ;;; ----------------
      ((and (pair? e) (eq? (car e) 'set!) (pair? (cdr e)) (pair? (cddr e)) (null? (cdddr e)))
       (cond ((const? (cadr e)) 
              (error "assignment to constant in" e))
             ((ormap (lambda (reserved) (eq? reserved (cadr e)))
                        '(define lambda if else cond and or quote unquote quasiquote let let* letrec set!))
              (error "reserved-word in" e))
             (else 
              `(set ,(parse (cadr e)) ,(parse (caddr e))))))
      
      ;;; DEFINE
      ;;; ------
      ((and (pair? e) (eq? (car e) 'define) (pair? (cdr e)) (pair? (cddr e)))
       (cond ((const? (cadr e)) 
              (error "definition of constant in" e))
             ((ormap (lambda (reserved) (eq? reserved (cadr e)))
                        '(define lambda if else cond and or quote unquote quasiquote let let* letrec set!))
              (error "reserved-word in" e))
             ((pair? (cadr e))                                 ;;; MIT Define 
              (parse (mit-expand e)))              
             (else                                             ;;; Regular Define
              `(define (var ,(cadr e)) ,(parse (caddr e))))))  
      
      ;;; EXPLICIT SEQUENCES (Begin)
      ;;; --------------------------
      ((and (pair? e) (eq? (car e) 'begin))
       (seq (map parse (cdr e))))
      
      ;;; APPLICATIONS
      ;;; ------------
      ((and (pair? e) (not (const? (car e))) (not (reserved? (car e))))
       `(applic ,(parse (car e)) ,(map parse (cdr e))))
      
      ;;; DISJUNCTIONS and CONJUCTIONS (or, and - reserved)
      ;;; ------------
      ((and (pair? e) (eq? (car e) 'or) (not (improper? e)))
       (cond ((null? (cdr e)) '#f)
             ((null? (cddr e)) (parse (cadr e)))
             (else `(or ,(map parse (cdr e))))))
      
      ((and (pair? e) (eq? (car e) 'and) (not (improper? e)))
       (parse (and-expand e)))     
      
      ;;; SPECIAL FORMS (let, let* - reserved)
      ;;; -------------
      ;;; let expressions
      ((and (pair? e) (eq? (car e) 'let) (pair? (cdr e)) (pair? (cddr e)))
       (parse (let-expand e)))
      
      ;;; let* expressions
      ((and (pair? e) (eq? (car e) 'let*) (pair? (cdr e)) (pair? (cddr e)))
       (parse (let*-expand e)))
      
      ;;; letrec expressions
      ((and (pair? e) (eq? (car e) 'letrec) (pair? (cdr e)) (pair? (cddr e)))
       (parse (letrec-expand e)))
      
      ;;; cond
      ((and (pair? e) (eq? (car e) 'cond) (not (improper? (cdr e))))
       (parse (cond-expand e)))
      
      (else (error "invalid-exp:" e)))))


;;; =========================================================
;;;         MACRO EXPANDERS (used by the tag parser)
;;; =========================================================
;;; qq-expand: Alan Bawden's code for expansion of quasiquotation
(define (qq-expand x)
  (cond ((tag-comma? x) (tag-data x))
	((tag-comma-atsign? x) (error "illegal"))
	((tag-backquote? x)
	 (qq-expand
	  (qq-expand (tag-data x))))
	((pair? x)
	 `(append ,(qq-expand-list (car x))
		  ,(qq-expand (cdr x))))
	(else `',x)))

(define (qq-expand-list x)
  (cond ((tag-comma? x) `(list ,(tag-data x)))
	((tag-comma-atsign? x) (tag-data x))
	((tag-backquote? x)
	 (qq-expand-list
	  (qq-expand (tag-data x))))
	((pair? x)
	 `(list
	   (append
	    ,(qq-expand-list (car x))
	    ,(qq-expand (cdr x)))))
	(else `'(,x))))

(define (tag-backquote? x) (and (pair? x) (eq? (car x) 'quasiquote)))
(define (tag-comma? x) (and (pair? x) (eq? (car x) 'unquote)))
(define (tag-comma-atsign? x) (and (pair? x) (eq? (car x) 'unquote-splicing)))
(define (tag-data x) (cadr x))

;;; if-2-expand(e)
;;; Macro-expand conditionals without the else-clause
;;; into an if-expression in which the else-clause is
;;; the constant void.
(define if-2-expand
  (lambda (e)
    (with e
      (lambda (_if test dit)
        `(if ,test ,dit ,(void))))))
  
;;; mit-expand(e)
;;; expand an MIT-style define expression (for procedures)
;;; into a regular define expression. e.g, the expression
;;; (define (goo x y) (+ x y)) is expanded into the exp:
;;; (define goo (lambda (x y) (+ x y))).
(define mit-expand
  (lambda (e)
    (let ((proc-name (caadr e))
          (vars (cdadr e))
          (body (cddr e)))
      `(define ,proc-name (lambda ,vars ,@body)))))

;;; and-expand
(define and-expand
  (lambda (e)
    (let ((preds (cdr e)))
      (letrec ((iter (lambda (preds)
                       (cond ((null? preds) '#t)
                             ((null? (cdr preds)) (car preds))
                             (else `(if ,(car preds) 
                                        ,(iter (cdr preds))
                                        ,#f))))))
        (iter preds)))))

;;; cond-expand
(define cond-expand
  (lambda (e)
    (let ((conds (cdr e)))
      (letrec ((iter (lambda (conds)
                       (cond ((null? conds) (void))
                             ((eq? 'else (caar conds))
                              (if (null? (cdr conds))
                                  `(begin ,@(cdar conds))
                                  (error "else clause must be last in:" e)))
                             (else `(if ,(caar conds) 
                                        (begin ,@(cdar conds))
                                        ,(iter (cdr conds))))))))
        (iter conds)))))

;;; let-expand(e)
;;; expand a let expression into an equivalent application.
;;; i.e, an expression of the form (let ((V1 E1) (V2 E2) ... (Vn En)) B1 ... Bn)
;;; is expanded into the application ((lambda (V1 ... Vn) B1 B2 ... Bn) E1 ... En).
(define let-expand
  (lambda (e)
    (let ((vars (map (lambda (var-exp) (car var-exp)) (cadr e)))
          (args (map (lambda (var-exp) (cadr var-exp)) (cadr e)))
          (exps (cddr e)))
      `((lambda ,vars ,@exps) ,@args))))

;;; let*-expand(e)
;;; expand a let* expression into an equivalent application.
;;; i.e, an expression of the form (let* ((V1 E1) (V2 E2) ... (Vn En)) B1 ... Bn)
;;; is rewritten as (let ((V1 E1)) (let ((V2 E2)) ...  (let ((Vn En)) B1 ... Bn)))
;;; AND further expanded as a let expression.
(define let*-expand
  (lambda (e)
    (let ((v1-e1 (caadr e))
          (rest  (cdadr e))
          (exps (cddr e)))
      (if (null? rest)
          `(let (,v1-e1) ,@exps)
          `(let (,v1-e1) ,(let*-expand `(let* ,rest ,@exps)))))))

; letrec-expand
(define letrec-expand
  (lambda (e)
    (let* ((vars  (map (lambda (v-e) `(,(car v-e) ,#f)) (cadr e)))
           (vi-ei (map (lambda (v-e) `(set! ,(car v-e) ,(cadr v-e))) (cadr e)))
           (exps (cddr e)))
      `(let ,vars ,@vi-ei (let () ,@exps)))))

;;; =========================================================
;;;                        BOX-SET
;;; =========================================================
;;; The procedure box-set takes as input a parsed expression, 
;;; and outputs a parsed expression in which all variables 
;;; that appear bound, and that are set anywhere in the code 
;;; (via the set! expression) are boxed. All references to 
;;; these variables are changed accordingly. All other 
;;; variables are left unchanged.
(define box-set
  (lambda (exp)
    (cond
      ((starts-with exp 'const)
       exp)
      
      ((starts-with exp 'var)
       exp)
      
      ((starts-with exp 'if-3)
       `(if-3 ,@(map (lambda (element) (box-set element)) (cdr exp))))
      
      ((starts-with exp 'lambda)
       (let ((to-box-params (intersection 
                             (acquire-set-params exp)
                             (acquire-used-params exp))))
         (if (null? to-box-params)  
             (if (equal? (car exp) 'lambda-opt)
                 `(,(car exp) ,(cadr exp) ,(caddr exp) ,(box-set (cadddr exp)))
                 `(,(car exp) ,(cadr exp) ,(box-set (caddr exp))))
             (if (equal? (car exp) 'lambda-opt)
                 (let ((set-block (map (lambda (v) `(set (var ,v) ,(box v))) to-box-params))
                       (body (box-set (unbox-exp (cadddr exp) to-box-params))))
                   `(,(car exp) ,(cadr exp) ,(caddr exp)
                                ,(if (starts-with body 'seq)
                                     `(seq (,@set-block ,@(cadr body)))
                                     `(seq (,@set-block ,body))))) 
                 (let ((set-block (map (lambda (v) `(set (var ,v) ,(box v))) to-box-params))
                       (body (box-set (unbox-exp (caddr exp) to-box-params))))
                   `(,(car exp) ,(cadr exp)
                                ,(if (starts-with body 'seq)
                                     `(seq (,@set-block ,@(cadr body)))
                                     `(seq (,@set-block ,body)))))))))

      ((starts-with exp 'set)
       `(set ,(cadr exp) ,(box-set (caddr exp))))
      
      ((starts-with exp 'define)
       `(define ,(cadr exp) ,(box-set (caddr exp))))
      
      ((starts-with exp 'applic)
       `(applic ,(box-set (cadr exp))
                ,(map (lambda (element) (box-set element)) (caddr exp))))
      
      ((starts-with exp 'seq)
       `(seq ,(map (lambda (element) (box-set element)) (cadr exp))))
      
      ((starts-with exp 'or)
       `(or ,(map (lambda (element) (box-set element)) (cadr exp))))
      
      (else
       (error "unknown expression" exp)))))

;;; Find variables that are set anywhere in the code
(define acquire-set-params
  (lambda (lambda-exp)
    (letrec ((extract (lambda (found not-found e)
                        (cond
                          ((null? e)  found)

                          ((or (starts-with e 'const) (starts-with e 'var))
                           found)
                          
                          ((starts-with e 'if-3)
                           (let ((res (extract '() not-found (cdr e))))
                             (append found res)))
                          
                          ((starts-with e 'lambda)
                           (let* ((non-ovridden (difference not-found (lambda-params e)))
                                  (result (extract '() non-ovridden (lambda-body e))))
                             (append found result)))
                          
                          ((or (starts-with e 'set) (starts-with e 'define))
                           (let ((res (extract '() not-found (caddr e))))
                             (if (member (cadadr e) (difference not-found res))
                                 (append found (cdadr e) res)
                                 (append found res))))
                          
                          ((starts-with e 'applic)
                           (let* ((res-operator (extract '() not-found (cadr e)))
                                  (res-operands  (extract '() (difference not-found res-operator) (caddr e))))
                             (append found res-operator res-operands)))
                          
                          ((starts-with e 'seq)
                           (let ((res (extract '() not-found (cadr e))))
                             (append found res)))
                          
                          ((starts-with e 'or)
                           (let ((res (extract '() not-found (cadr e))))
                             (append found res)))
                          
                          (else
                           (let* ((res-car (extract '() not-found (car e)))
                                  (res-cdr (extract '() (difference not-found res-car) (cdr e))))
                             (append found res-car res-cdr)))))))

      (extract '() (lambda-params lambda-exp) (lambda-body lambda-exp)))))

;;; Find variables that appear bound. For example: in the following 
;;; expression, the variable b is considered bound and the variable
;;; a is not: '(lambda (a b) (a ((lambda (x) (+ b 1)) 3)))
;;; the result in this case should be: (b)
(define acquire-used-params
  (lambda (lambda-exp)
    (letrec ((extract (lambda (found not-found e in-lambda)
                        (cond
                          ((null? e) found)
                          
                          ((starts-with e 'const)
                           found)
                        
                          ((starts-with e 'var)
                           (if (and (member (cadr e) not-found)
                                    in-lambda)
                               (append found (cdr e))
                               found))
                          
                          ((starts-with e 'if-3)
                           (let ((res (extract '() not-found (cdr e) in-lambda)))
                             (append found res)))
                          
                          ((starts-with e 'lambda)
                           (let* ((non-ovridden (difference not-found (lambda-params e)))
                                  (result (extract '() non-ovridden (lambda-body e) #t)))
                             (append found result)))
                          
                          ((or 
                            (starts-with e 'set)
                            (starts-with e 'define))
                           (let* ((res-caddr (extract '() not-found (caddr e) in-lambda))
                                 (res-cadr (extract '() (difference not-found res-caddr) (cadr e) in-lambda)))
                                 (append found res-cadr res-caddr)))
                          
                          ((starts-with e 'applic)
                           (let* ((res-operator (extract '() not-found (cadr e) in-lambda))
                                  (res-operands  (extract '() (difference not-found res-operator) (caddr e) in-lambda)))
                             (append found res-operator res-operands)))
                          
                          ((starts-with e 'seq)
                           (let ((res (extract '() not-found (cadr e) in-lambda)))
                             (append found res)))
                          
                          ((starts-with e 'or)
                           (let ((res (extract '() not-found (cadr e) in-lambda)))
                             (append found res)))
                          
                          (else
                           (let* ((res-car (extract '() not-found (car e) in-lambda))
                                  (res-cdr (extract '() (difference not-found res-car) (cdr e) in-lambda)))
                             (append found res-car res-cdr)))))))

      (extract '() (lambda-params lambda-exp) (lambda-body lambda-exp) #f))))


(define unbox-exp
  (lambda (body to-unbox-args)
    (cond
      ((starts-with body 'const)
       body)
      
      ((starts-with body 'var)
       (if (member (cadr body) to-unbox-args)
           (unbox (cadr body))
           body))
      
      ((starts-with body 'if-3)
       `(if-3 ,@(map (lambda (element) (unbox-exp element to-unbox-args)) (cdr body))))
      
      ((starts-with body 'lambda)
       (if (equal? (car body) 'lambda-opt)
           `(,(car body) ,(cadr body) ,(caddr body) 
                         ,(unbox-exp (cadddr body) (difference to-unbox-args (lambda-params body))))
           `(,(car body) ,(cadr body)
                         ,(unbox-exp (caddr body) (difference to-unbox-args (lambda-params body))))))
      
      ((starts-with body 'set)
       (if  (equal? (caadr body) 'var) 
            (if (member (cadadr body) to-unbox-args) 
                `(applic (var set-car!) (,(cadr body) ,(unbox-exp (caddr body) to-unbox-args))) 
                `(set ,(unbox-exp (cadr body) to-unbox-args) ,(unbox-exp (caddr body) to-unbox-args)))
            `(set ,(unbox-exp (cadr body) to-unbox-args) ,(unbox-exp (caddr body) to-unbox-args))))
      
      ((starts-with body 'define)
       (if  (equal? (caadr body) 'var) 
            (if (member (cadadr body) to-unbox-args) 
                `(applic (var set-car!) (,(cadr body) ,(unbox-exp (caddr body) to-unbox-args))) 
                `(define ,(unbox-exp (cadr body) to-unbox-args) ,(unbox-exp (caddr body) to-unbox-args)))
            `(define ,(unbox-exp (cadr body) to-unbox-args) ,(unbox-exp (caddr body) to-unbox-args))))
       
      ((starts-with body 'applic)
       `(applic ,(unbox-exp (cadr body) to-unbox-args)
                ,(map (lambda (element) (unbox-exp element to-unbox-args)) (caddr body))))
      
      ((starts-with body 'seq)
       `(seq ,(map (lambda (element) (unbox-exp element to-unbox-args)) (cadr body))))
      
      ((starts-with body 'or)
       `(or ,(map (lambda (element) (unbox-exp element to-unbox-args)) (cadr body))))
      
      (else
       (error "unknown expression" body)))))


;;; =========================================================
;;;                    ANNOTATE-TAIL-CALLS
;;; =========================================================
(define annotate-tail-calls
  (lambda (e)
    (letrec 
        ((helper
          (lambda (e tp)
            (cond
              ((null? e) e)
              ((or (starts-with e 'const) (starts-with e 'var)) e)
              ((starts-with e 'if-3)
               (let ((test (cadr e))
                     (dit  (caddr e))
                     (dif  (cadddr e)))
                 `(if-3 ,(helper test #f)
                        ,(helper dit  tp)
                        ,(helper dif  tp))))
              ((or (starts-with e 'lambda-simple) (starts-with e 'lambda-variadic))
               (let ((args (cadr e))
                     (body (caddr e)))
                 `(,(car e) ,args ,(helper body #t))))
              ((starts-with e 'lambda-opt)
               (let ((args (cadr e))
                     (opt  (caddr e))
                     (body (cadddr e)))
                 `(,(car e) ,args ,opt ,(helper body #t))))
              ((starts-with e 'set)
               `(set ,(cadr e) ,(helper (caddr e) #f)))
              ((starts-with e 'define)
               `(define ,(cadr e) ,(helper (caddr e) #f)))
              ((starts-with e 'applic)
               (let ((operator (cadr e))
                     (operands (caddr e)))
                 (if (eq? tp #f)
                     `(applic ,(helper operator #f)
                              ,(map (lambda (operand) (helper operand #f))
                                    operands))
                     `(tc-applic ,(helper operator #f)
                                 ,(map (lambda (operand) (helper operand #f))
                                       operands)))))
              ((starts-with e 'seq)
               `(seq ,(helper (cadr e) #f)))
              ((starts-with e 'or)
               `(or ,(helper (cadr e) #f)))
              ((pair? e)
               (if (null? (cdr e))
                   `(,(helper (car e) #t))
                   `(,(helper (car e) #f) ,@(helper (cdr e) #f))))
              (else
               (error "unknown expression" e))))))
      (helper e #t))))

;;; =========================================================
;;;                        PE->LEX-PE
;;; =========================================================
(define pe->lex-pe
  (lambda (e)
    (letrec ((helper 
              (lambda (e params env)
                (cond 
                  ((null? e) e)
                  ((starts-with e 'const)
                   e)
                  ((starts-with e 'var)
                   (if (param? (cadr e) params)
                       `(param-var ,(cadr e) ,(find-minor (cadr e) params))
                       (let ((major-minor (find-major-minor (cadr e) env)))
                         (if major-minor
                             `(bound-var ,(cadr e) ,(car major-minor) ,(cdr major-minor))
                             `(free-var ,(cadr e))))))
                  ((starts-with e 'if-3)
                   (let ((test (cadr e))
                         (dit  (caddr e))
                         (dif  (cadddr e)))
                     `(if-3 ,(helper test params env)
                            ,(helper dit  params env)
                            ,(helper dif  params env))))
                  ((starts-with e 'lambda-simple)
                   `(lambda-simple ,(cadr e) ,(helper (caddr e) (cadr e) (cons params env))))
                  ((starts-with e 'lambda-variadic)
                   `(lambda-variadic ,(cadr e) ,(helper (caddr e) (list (cadr e)) (cons params env))))
                  ((starts-with e 'lambda-opt)
                   `(lambda-opt ,(cadr e) ,(caddr e) ,(helper (cadddr e) `(,@(cadr e) ,(caddr e))
                                                                  (cons params env))))
                  ((starts-with e 'set)
                   `(set ,(helper (cadr e) params env) ,(helper (caddr e) params env)))
                  ((starts-with e 'define)
                   `(define ,(helper (cadr e) params env) ,(helper (caddr e) params env)))
                  ((or (starts-with e 'applic) (starts-with e 'tc-applic))
                   `(,(car e) ,(helper (cadr e) params env) ,(helper (caddr e) params env)))
                  ((starts-with e 'seq)
                   `(seq ,(helper (cadr e) params env)))
                  ((starts-with e 'or)
                   `(or ,(helper (cadr e) params env)))
                  ((pair? e)
                   `(,(helper (car e) params env) ,@(helper (cdr e) params env)))
                  (else
                   (error "unknown expression" e))))))
      (helper e () ()))))

;;; =========================================================
;;;                   AUXILIARY PROCEDURES
;;; =========================================================
(define with (lambda (s f) (apply f s)))

(define split
  (lambda (s ret-proper ret-rdc+rac)
    (cond ((null? s) (ret-proper))
          ((pair? s)
           (split (cdr s) 
                  ret-proper
                  (lambda (rdc rac)
                    (ret-rdc+rac (cons (car s) rdc) rac))))
          (else (ret-rdc+rac '() s)))))

(define improper? 
  (lambda (s)
    (split s (lambda () #f) (lambda (pre-dot post-dot) `(,pre-dot ,post-dot)))))
         

(define void
  (let ((v (if #f #f)))
    (lambda ()
      v)))

(define void?
  (lambda (e) (eq? e (void))))

(define split-define
  (lambda (body)
    (letrec 
        ((split 
          (lambda (def-block rest)
            (cond ((andmap 
                    (lambda (exp) 
                      (not (and (pair? exp)
                                (eq? 'define (car exp))))) 
                    rest)    
                   ;;; rest includes no define
                   (cons def-block rest))
                  ((eq? 'define (caar rest)) 
                   (split `(,@def-block ,(car rest)) (cdr rest)))
                  (else 
                   (error "define must be located at the beginning in: " body))))))
      (split '() body))))
    
;;; seq(e)
;;; if e is a sequence of more than one exprssion, the
;;; returned value is (seq (e1 ... en)). else, e is a
;;; list containing one expression and the return value
;;; is that single expression.
(define seq
  (lambda (e)
    (if (and (pair? e) (null? (cdr e)))
        (car e)
        `(seq ,e))))
  
;;; const?(e)
;;; Check whether or not the expression e is a constant.
(define const?
  (lambda (e)
    (ormap (lambda (pred?) (pred? e))
           `(,boolean? ,char? ,number?, string? ,vector?, void?))))

;;; reserved?(e)
;;; Check whether or not the exp e is a reserved word.
(define reserved? 
  (lambda (e)
    (ormap (lambda (reserved) (eq? reserved e))
           '(define begin lambda if else cond and or quote unquote quasiquote let let* letrec set!))))

;;; set?(l)
;;; Check that there are no duplicate elements in a 
;;; given list. I.e, the list forms a set.
(define set?
  (lambda (l)
    (cond ((null? l) #t)
          ((ormap (lambda (el) (eq? el (car l))) (cdr l)) #f)
          (else (set? (cdr l))))))

(define box
  (lambda (v)
    `(applic (var cons) ((var ,v) (const ())))))

(define unbox
  (lambda (v)
    `(applic (var car) ((var ,v)))))

(define starts-with
  (lambda (e word)
    (if (eq? word 'lambda)
        (member (car e) '(lambda-simple lambda-variadic lambda-opt))
        (eq? (car e) word))))

(define lambda-params
  (lambda (e)
    (cond ((eq? 'lambda-simple   (car e)) (cadr e))
          ((eq? 'lambda-opt      (car e)) (cons (caddr e) (cadr e)))
          ((eq? 'lambda-variadic (car e)) (list (cadr e))))))

(define lambda-body
  (lambda (e)
    (cond ((eq? 'lambda-simple   (car e)) (caddr e))
          ((eq? 'lambda-opt      (car e)) (cadddr e))
          ((eq? 'lambda-variadic (car e)) (caddr e)))))
                                           
(define difference 
  (lambda (l1 l2)
    (cond ((null? l1) ())
          ((member (car l1) l2) (difference (cdr l1) l2))
          (else (cons (car l1) (difference (cdr l1) l2))))))

(define intersection
  (lambda (l1 l2)
    (cond ((or (null? l1) 
               (null? l2)) ())
          ((member (car l1) l2)
           (cons (car l1)
                 (intersection (cdr l1) l2)))
          (else (intersection (cdr l1) l2)))))

(define find-minor
  (lambda (name lst)
    (letrec ((helper
              (lambda (name index lst)
                (if (null? lst)
                    #f
                    (if (equal? name (car lst))
                        index
                        (helper name (+ 1 index) (cdr lst)))))))
    (helper name 0 lst))))

(define find-major-minor
  (lambda (name env)
    (letrec ((helper
              (lambda (name env major) 
                (if (null? env)
                    #f
                    (let ((minor (find-minor name (car env))))
                      (if (not minor)
                          (helper name (cdr env) (+ major 1))
                          (cons major minor)))))))
      (helper name env 0))))
    
(define param?
  (lambda (name params)
    (member name params)))

;;; =========================================================
;;;                         COMPILE
;;; =========================================================
(define apply-all
  (lambda (e)
    (pe->lex-pe (annotate-tail-calls (box-set (parse e))))))

(define get-triple
  (lambda (triple cmd)
    (cond ((equal? cmd 'def)  (car triple))
          ((equal? cmd 'init) (cadr triple))
          ((equal? cmd 'code) (caddr triple)))))

(define append-triple
  (lambda (tripleA def init code)
    (let ((d (string-append (get-triple tripleA 'def)  def))
          (i (string-append (get-triple tripleA 'init) init))
          (c (string-append (get-triple tripleA 'code) code)))
      `(,d ,i ,c))))
          

;(define generate-prim-unary
;  (lambda (action name)
;    (let ((def "")
;          (init (string-append
;                 "static strtuct L" name ":\n"
;                 "if (stack[fp-3]!=1)\n"
;                 "\tgoto Error;\n"
;                 "r1=stack[fp-4];\n"
;                 action
;                 "goto *pop();\n"))
;          (code (string-append
 ;                "L" name ":\n"
 ;;                "if (stack[fp-3]!=1)\n"
 ;                "\tgoto Error;\n"
 ;                "r1=stack[fp-4];\n"
 ;                action
  ;               "goto *pop();\n"))
